home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-02 / asorts.zip / ASORTS.PAS < prev    next >
Pascal/Delphi Source File  |  1993-01-04  |  18KB  |  521 lines
  1. unit asorts;                               {Last modified: 09APR91}
  2. { General-purpose array manipulation routines }
  3. { Copyright 1991, J. W. Rider }
  4.  
  5. { Notice:  This unit makes extensive use of array types that exceed the
  6.   maximum "safe" size of 65519 bytes.  While the compiler "allows" the
  7.   declaration without error, application program should not ordinarily try
  8.   to allocate memory to such structures.  Segment wraparound problems can
  9.   otherwise occur.  For instance, most of these routines will not work on an
  10.   array that "straddles" a segment boundary.  If you notice carefully in
  11.   this unit, the large arrays are used only for typecasting purposes, and
  12.   no memory is allocated to them. }
  13.  
  14. interface
  15.  
  16. { $define MONITOR} { <--- remove space before "$" to enable
  17.                           monitoring various sorting routines }
  18. {$ifdef MONITOR}
  19. var monitor : procedure; { for monitoring results of sort }
  20. procedure nullmonitor; { to turn monitoring off }
  21. {$endif}
  22.  
  23.  
  24.                        { *** Type definitions *** }
  25.  
  26. { "comparefunc" -- comparison function argument for "qsort", "bsearch"
  27.                    "lfind" and "lsearch"
  28.  
  29.   "icomparefunc"-- comparison function argument for "virtual" routines
  30.  
  31.   "swapproc"    -- exchange procedure for "virtual" routines
  32.  
  33.   "testfunc"    -- test function argument for "scan" }
  34.  
  35. type comparefunc = function (var a,b):longint;
  36.      icomparefunc= function (a,b:longint):longint;
  37.      swapproc    = procedure(a,b:longint);
  38.      testfunc    = function (var a):boolean;
  39.  
  40.  
  41.                    { *** C compatibility routines *** }
  42.  
  43. { "qsort", "bsearch", "lfind", "lsearch" and "swab" are analogous to
  44.    standard C functions of the same names }
  45.  
  46. { quicksort the elements of an array }
  47. procedure qsort(var base; length_base, sizeof_element:word;
  48.                 f:comparefunc);
  49.  
  50. { binary search a sorted array for an element}
  51. function bsearch(var key,base; length_base, sizeof_element:word;
  52.                  f:comparefunc):word;
  53.  
  54. { linear search an array for an element }
  55. function lfind(var key,base; length_base, sizeof_element:word;
  56.                  f:comparefunc):word;
  57.  
  58. { linear search an array for an element; append if not found }
  59. function lsearch(var key,base; length_base, sizeof_element:word;
  60.                  f:comparefunc):word;
  61.  
  62. { move one array of words to another, swapping bytes }
  63. procedure swab(var source, destination; numwords:word);
  64.  
  65.  
  66.        { *** "riderized" (i.e, generally nonstandard) routines *** }
  67.  
  68. { the remaining routines generally have no standard implementation in other
  69.   languages }
  70.  
  71. { binary search a sorted array for an element.  Return the index of
  72.   its location, or the negative of the index where it should be inserted }
  73. function bfind(var key,base; length_base, sizeof_element:word;
  74.                  f:comparefunc):longint;
  75.  
  76. { inserts an element into a sorted array. }
  77. function binsert(var key,base; length_base, sizeof_element:word;
  78.                  f:comparefunc):word;
  79.  
  80. { fibonacci search a sorted array; marginally faster than "bsearch" }
  81. function fibsearch(var key,base; length_base, sizeof_element:word;
  82.                    f:comparefunc):word;
  83.  
  84. { fill an array with an element }
  85. procedure fill(var key,destination; count, sizeof_element:word);
  86.  
  87. { order an array by the "heapsort" algorithm }
  88. procedure heapsort(var base; length_base, sizeof_element:word;
  89.                     f:comparefunc);
  90.  
  91. { return the address of variable as a longint value }
  92. function longaddr(var x):longint;
  93.  
  94. { a not-so-quick sorting routine, compare with qsort }
  95. procedure naivesort(var base; length_base, sizeof_element:word;
  96.                     f:comparefunc);
  97.  
  98. { scan a subarray for the first element that meets a specific criteria }
  99. function scan(var source; count, sizeof_element:word; f:testfunc):word;
  100.  
  101. { order an array by the "selection sort" algorithm }
  102. procedure selsort(var base; length_base, sizeof_element:word;
  103.                   f:comparefunc);
  104.  
  105. { order an array by the "shell sort" algorithm }
  106. procedure shellsort(var base; length_base, sizeof_element:word;
  107.                     f:comparefunc);
  108.  
  109. { randomly permute the elements of an array }
  110. procedure shuffle(var base; length_base, sizeof_element:word);
  111.  
  112. { fill a subarray with an element }
  113. procedure subfill(var key,destination;
  114.                   count, sizeof_key,sizeof_element:word);
  115.  
  116. { move subarray to array or array to subarray }
  117. procedure submove(var source,destination;
  118.                   count, sizeof_source, sizeof_destination:word);
  119.  
  120. { swap two elements or variables of the same size }
  121. procedure swap(var var1,var2; sizeof_element:word);
  122.  
  123. { sort a "virtual" array by the quicksort algorithm }
  124. procedure vqsort(length_base:longint; f:icomparefunc; s:swapproc);
  125.  
  126. { sort a "virtual" array by using a selection sort algorithm }
  127. procedure vselsort(length_base:longint; f:icomparefunc; s:swapproc);
  128.  
  129. { randomly permute a "virtual" array }
  130. procedure vshuffle(length_base:longint; s:swapproc);
  131.  
  132. { move subarray to subarray }
  133. procedure xsubmove(var source,destination;
  134.              count,sizeof_source,sizeof_destination,sizeof_move:word);
  135.  
  136. implementation
  137.  
  138. function bfind(var key,base; length_base, sizeof_element:word;
  139.                  f:comparefunc):longint;
  140. var b:array [0..$fffe] of byte absolute base; l,h,x,c:longint;
  141. begin if length_base>0 then begin
  142.          l:=0; h:=pred(length_base);
  143.          repeat
  144.             x:=(l+h) shr 1; c:=f(key,b[x*sizeof_element]);
  145.             if      c<0 then h:=pred(x)
  146.             else if c>0 then l:=succ(x)
  147.             else{if c=0 then}begin bfind:=succ(x); exit; end;
  148.          until l>h;
  149.          bfind:=-l; end
  150.       else bfind:=0; end;
  151.  
  152.  
  153. function binsert(var key,base;length_base,sizeof_element:word;
  154.                    f:comparefunc):word;
  155. var b:array [0..$fffe] of byte absolute base; x:longint;
  156. begin
  157.    x:=bfind(key,base,length_base,sizeof_element,f);
  158.    if x<=0 then x:=-x else dec(x);
  159.    move(b[x*sizeof_element],b[succ(x)*sizeof_element],
  160.         (length_base-x)*sizeof_element);
  161.    move(key,b[x*sizeof_element],sizeof_element);
  162.    binsert:=succ(x); end;
  163.  
  164.  
  165. function bsearch(var key,base; length_base, sizeof_element:word;
  166.                  f:comparefunc):word;
  167. var c:longint;
  168. begin
  169.    c:=bfind(key,base,length_base,sizeof_element,f);
  170.    if c>0 then bsearch:=c
  171.    else bsearch:=0; end;
  172.  
  173.  
  174. function fibsearch(var key,base; length_base, sizeof_element:word;
  175.                    f:comparefunc):word;
  176. var b:array [0..$fffe] of byte absolute base; i,p,q,imax:word; t:longint;
  177. begin
  178.   imax:=length_base*sizeof_element;
  179.   q:=0; p:=sizeof_element; i:=p+q; { set up for fibonacci sequencing }
  180.   while imax>(i+p) do begin q:=p; p:=i; inc(i,q); end;
  181.   dec(i,sizeof_element); {zero-base adjustment}
  182.   while true do begin
  183.         if i<imax then t:=f(key,b[i])
  184.         else           t:=-1; { simulate "too big" for "out of range" }
  185.         if t=0 then begin fibsearch:=succ(i div sizeof_element); exit end
  186.         else if t<0 then
  187.              if q=0 then begin fibsearch:=0; exit end
  188.              else begin dec(i,q); q:=p-q; dec(p,q) end
  189.         else { if t>0 then }
  190.              if p=sizeof_element then begin fibsearch:=0; exit end
  191.              else begin inc(i,q); dec(p,q); dec(q,p) end end end;
  192.  
  193.  
  194. procedure fill(var key,destination; count, sizeof_element:word);
  195. var b:array [0..$fffe] of byte absolute destination;
  196.     x,moved:word;
  197. begin if count>0 then begin
  198.          move(key,destination,sizeof_element);
  199.          moved:=1; dec(count); x:=sizeof_element;
  200.          while count>moved do begin
  201.             move(destination,b[x],x);
  202.             dec(count,moved); moved:=moved shl 1; x:=x shl 1; end;
  203.          move(destination,b[x],count*sizeof_element); end; end;
  204.  
  205.  
  206. procedure heapsort(var base; length_base, sizeof_element:word;
  207.                     f:comparefunc);
  208. var b: array[0..$fffe] of byte absolute base;
  209.     p:pointer; nx:longint; k,kx:word;
  210.  
  211.     procedure aux1(kx:word);
  212.  
  213.        procedure aux2; var jx:word;
  214.        begin
  215.           while kx<=(nx shr 1) do begin
  216.                 jx:=kx shl 1;
  217.                 if (jx<nx) and (f(b[jx],b[jx+sizeof_element])<0) then
  218.                    inc(jx,sizeof_element);
  219.                 if f(p^,b[jx])>=0 then exit;
  220.                 move(b[jx],b[kx],sizeof_element);
  221.                 {$ifdef MONITOR}
  222.                 if @monitor<>nil then monitor;
  223.                 {$endif}
  224.                 kx:=jx end end;
  225.  
  226.     begin {aux1}
  227.        move(b[kx],p^,sizeof_element);
  228.        {$ifdef MONITOR}
  229.        if @monitor<>nil then monitor;
  230.        {$endif}
  231.        aux2;
  232.        move(p^,b[kx],sizeof_element);
  233.        {$ifdef MONITOR}
  234.        if @monitor<>nil then monitor;
  235.        {$endif}
  236.        end;
  237.  
  238. begin {heapsort}
  239.    getmem(p,sizeof_element);
  240.    nx:=pred(length_base)*sizeof_element;
  241.    for k:=(length_base shr 1) downto 1 do aux1(pred(k)*sizeof_element);
  242.    repeat
  243.       swap(b[0],b[nx],sizeof_element);
  244.       {$ifdef MONITOR}
  245.       if @monitor<>nil then begin monitor; monitor; monitor end;
  246.       {$endif}
  247.       dec(nx,sizeof_element);
  248.       aux1(0);
  249.       until nx<=0;
  250.    freemem(p,sizeof_element) end;
  251.  
  252. function lfind(var key,base; length_base, sizeof_element:word;
  253.                  f:comparefunc):word;
  254. var b:array [0..$fffe] of byte absolute base; i,j:word;
  255. begin
  256.    j:=0;
  257.    for i:=1 to length_base do begin
  258.        if f(key,b[j])=0 then begin lfind:=i; exit end;
  259.        inc(j,sizeof_element); end;
  260.    lfind:=0; end;
  261.  
  262.  
  263. function longaddr(var x):longint;
  264. begin longaddr:=(longint(seg(x)) shl 4) + ofs(x); end;
  265.  
  266.  
  267. function lsearch(var key,base; length_base, sizeof_element:word;
  268.                  f:comparefunc):word;
  269. var b:array [0..$fffe] of byte absolute base; i:word;
  270. begin
  271.    i:=lfind(key,base,length_base,sizeof_element,f);
  272.    if i=0 then begin
  273.       move(key,b[length_base*sizeof_element],sizeof_element);
  274.       lsearch:=succ(length_base); end
  275.    else lsearch:=i; end;
  276.  
  277. procedure naivesort(var base; length_base, sizeof_element:word;
  278.                     f:comparefunc);
  279. var b: array[0..$fffe] of byte absolute base;
  280.     i,j,l,r:word;
  281. begin
  282. i:=0;
  283. for l:=1 to pred(length_base) do begin
  284.    j:=i+sizeof_element;
  285.    for r:=succ(l) to length_base do begin
  286.        if f(b[i],b[j])>0 then begin
  287.           swap(b[i],b[j],sizeof_element);
  288.           {$ifdef MONITOR}
  289.           if @monitor<>nil then monitor;
  290.           {$endif}
  291.           end;
  292.        inc(j,sizeof_element); end;
  293.    inc(i,sizeof_element); end; end;
  294.  
  295. {$ifdef MONITOR}
  296. { dummy "monitor" }
  297. procedure nullmonitor; begin pointer((@@monitor)^):=NIL end;
  298. {$endif}
  299.  
  300. procedure qsort(var base; length_base, sizeof_element:word;
  301.                     f:comparefunc);
  302. var b: array[0..$fffe] of byte absolute base;
  303.     j:longint; x:word; { not preserved during recursion }
  304.  
  305.     procedure sort(l,r: word);
  306.     var i:longint;
  307.     begin
  308.       i:=l*sizeof_element;
  309.       while l<r do begin
  310.          j:=r*sizeof_element;
  311.          x:=((longint(l)+r) SHR 1)*sizeof_element;
  312.          while i<j do begin
  313.            while f(b[i],b[x])<0 do inc(i,sizeof_element);
  314.            while f(b[x],b[j])<0 do dec(j,sizeof_element);
  315.            if i<j then begin
  316.               swap(b[i],b[j],sizeof_element);
  317.               if i=x then x:=j else if j=x then x:=i;
  318.               {$ifdef MONITOR}
  319.               if @monitor<>nil then monitor;
  320.               {$endif}
  321.               end;
  322.            if i<=j then begin
  323.               inc(i,sizeof_element); dec(j,sizeof_element) end; end;
  324.          if (l*sizeof_element)<j then sort(l,j div sizeof_element);
  325.          l:=i div sizeof_element; end; end;
  326.  
  327. begin sort(0,pred(length_base)); end; {procedure qsort}
  328.  
  329.  
  330. function scan(var source; count, sizeof_element:word; f:testfunc):word;
  331. var b:array[0..$fffe] of byte absolute source;
  332.     i,j:word;
  333. begin
  334.    j:=0;
  335.    for i:=1 to count do begin
  336.        if f(b[j]) then begin scan:=i; exit; end;
  337.        inc(j,sizeof_element); end;
  338.    scan:=0; end;
  339.  
  340.  
  341. procedure selsort(var base; length_base, sizeof_element:word;
  342.                    f:comparefunc);
  343. var b:array[0..$fffe] of byte absolute base;
  344.     i,ix,j,jx,k,kx:word;
  345. begin
  346. ix:=0;
  347. for i:=1 to pred(length_base) do begin
  348.     kx:=ix; jx:=ix;
  349.     for j:=succ(i) to length_base do begin
  350.         inc(jx,sizeof_element);
  351.         if f(b[jx],b[kx])<0 then kx:=jx end;
  352.     if kx<>ix then begin
  353.        swap(b[kx],b[ix],sizeof_element);
  354.        {$ifdef MONITOR}
  355.        if @monitor<>nil then monitor;
  356.        {$endif}
  357.        end; inc(ix,sizeof_element) end; end;
  358.  
  359.  
  360. procedure shellsort(var base; length_base, sizeof_element:word;
  361.                    f:comparefunc);
  362. var b:array[0..$fffe] of byte absolute base;
  363.     p:pointer; h,jx:longint; i,hx,ix:word;
  364.  
  365.     procedure aux; begin
  366.         while f(b[jx-hx],p^)>0 do begin
  367.             move(b[jx-hx],b[jx],length_base); dec(jx,hx);
  368.             {$ifdef MONITOR}
  369.             if @monitor<>nil then monitor;
  370.             {$endif}
  371.             if jx<hx then exit end end;
  372.  
  373. begin if length_base>0 then begin
  374.    getmem(p,length_base);
  375.    if p<>nil then begin
  376.       h:=1; repeat h:=3*h+1 until h>length_base;
  377.       repeat
  378.          h:=h div 3; hx:=h*sizeof_element; ix:=hx;
  379.          for i:=succ(h) to length_base do begin
  380.              move(b[ix],p^,sizeof_element);
  381.              {$ifdef MONITOR}
  382.              if @monitor<>nil then monitor;
  383.              {$endif}
  384.              jx:=ix; aux;
  385.              if jx<>ix then move(p^,b[jx],sizeof_element);
  386.              {$ifdef MONITOR}
  387.              if @monitor<>nil then monitor;
  388.              {$endif}
  389.              inc(ix,sizeof_element) end;
  390.          until h=1;
  391.       freemem(p,length_base) end end end;
  392.  
  393.  
  394. procedure shuffle(var base; length_base, sizeof_element:word);
  395. var b: array[0..$fffe] of byte absolute base;
  396.     i,ix,j,jx:word;
  397. begin if length_base>0 then
  398.   for i:=pred(length_base) downto 1 do begin
  399.       ix:=i*sizeof_element;
  400.       j:=random(succ(i));
  401.       if i<>j then begin
  402.          jx:=j*sizeof_element;
  403.          swap(b[ix],b[jx],sizeof_element); end; end; end;
  404.  
  405.  
  406. procedure subfill(var key,destination;
  407.                   count, sizeof_key,sizeof_element:word);
  408. var b:array [0..$fffe] of byte absolute destination; i,j:word;
  409. begin
  410.   j:=0;
  411.   for i:=1 to count do begin
  412.       move(key,b[j],sizeof_key);
  413.       inc(j,sizeof_element); end; end;
  414.  
  415.  
  416. procedure submove(var source, destination;
  417.                   count, sizeof_source,sizeof_destination:word);
  418. var sm:word;
  419. begin if sizeof_source=sizeof_destination then
  420.          move(source,destination,count*sizeof_source)
  421.       else begin
  422.          if sizeof_source>sizeof_destination then sm:=sizeof_destination
  423.          else                                     sm:=sizeof_source;
  424.       xsubmove(source,destination,
  425.                count,sizeof_source,sizeof_destination,sm); end; end;
  426.  
  427.  
  428. procedure swab(var source, destination; numwords:word);
  429. var a: array [1..$7fff] of word absolute source;
  430.     b: array [1..$7fff] of word absolute destination;
  431.     i:word;
  432.  
  433. begin if longaddr(source)>=longaddr(destination) then
  434.          for i:=1 to numwords do b[i]:=system.swap(a[i])
  435.       else
  436.          for i:=numwords downto 1 do b[i]:=system.swap(a[i]) end;
  437.  
  438.  
  439. procedure swap(var var1,var2; sizeof_element:word);
  440. type chunk = array [0..$f] of byte;
  441. var a:array [0..$fffe] of byte absolute var1;
  442.     b:array [0..$fffe] of byte absolute var2;
  443.     ac: array [1..$fff] of chunk absolute var1;
  444.     bc: array [1..$fff] of chunk absolute var2;
  445.     c:chunk; { swap buffer }
  446.     k:byte; x:word;
  447.  
  448.     procedure swapchunk(var e,f:chunk);
  449.     begin c:=e; e:=f; f:=c; end;
  450.  
  451.     procedure swapbytes(var e,f; len:byte);
  452.     begin move(e,c,len); move(f,e,len); move(c,f,len); end;
  453.  
  454. begin
  455.    for k:=1 to (sizeof_element shr 4) do swapchunk(ac[k],bc[k]);
  456.    k:=(sizeof_element and $f);
  457.    if k>0 then begin
  458.       x:=(sizeof_element and $fff0); swapbytes(a[x],b[x],k); end; end;
  459.  
  460.  
  461. procedure vqsort(length_base:longint; f:icomparefunc; s:swapproc);
  462. var j,x:longint; { not preserved during recursion }
  463.  
  464.     procedure sort(l,r:longint);
  465.     var i:longint;
  466.     begin
  467.       i:=l; j:=r;
  468.       x:=(i+j) SHR 1;
  469.       while i<j do begin
  470.         while f(i,x)<0 do inc(i);
  471.         while f(x,j)<0 do dec(j);
  472.         if i<j then begin
  473.            s(i,j);
  474.            if i=x then x:=j else if j=x then x:=i; end;
  475.         if i<=j then begin inc(i); dec(j) end; end;
  476.       if l<j then sort(l,j);
  477.       if i<r then sort(i,r); end;
  478.  
  479. begin sort(1,length_base); end; {procedure vqsort}
  480.  
  481.  
  482. procedure vselsort(length_base:longint; f:icomparefunc; s:swapproc);
  483. var i,j,k:longint;
  484. begin for i:=1 to pred(length_base) do begin
  485.     k:=i;
  486.     for j:=succ(i) to length_base do if f(j,k)<0 then k:=j;
  487.     if k<>i then s(k,i) end end;
  488.  
  489.  
  490. procedure vshuffle(length_base:longint; s:swapproc);
  491. var i,j:longint;
  492. begin for i:=length_base downto 2 do begin
  493.       j:=succ(random(i));
  494.       if i<>j then begin s(i,j); end; end; end;
  495.  
  496.  
  497. procedure xsubmove(var source,destination;
  498.              count,sizeof_source,sizeof_destination,sizeof_move:word);
  499. var a:array [0..$fffe] of byte absolute destination;
  500.     b:array [0..$fffe] of byte absolute source;
  501.     i,j,k:word; r:boolean;
  502. begin
  503.    r:=longaddr(source)>=longaddr(destination);
  504.    if r then begin j:=0; k:=0; end
  505.    else begin
  506.       j:=pred(count)*sizeof_destination; k:=pred(count)*sizeof_source; end;
  507.    for i:=1 to count do begin
  508.        move(b[k],a[j],sizeof_move);
  509.        if r then begin
  510.           inc(j,sizeof_destination); inc(k,sizeof_source) end
  511.        else begin
  512.           dec(j,sizeof_destination); dec(k,sizeof_source) end; end; end;
  513.  
  514.  
  515. {$ifdef MONITOR}
  516. begin {initialization}
  517. nullmonitor;
  518. {$endif}
  519.  
  520. end.
  521.